home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / DELPHI / SOCKV3.ZIP / FTP.ZIP / FTP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-03-18  |  21.5 KB  |  856 lines
  1. unit Ftp;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls, Menus, Sockets, Login, FileGet, FilePut,
  8.   FileRen, FileView, IniFiles, Meter, WinSock;
  9. type
  10.   TFTPForm = class(TForm)
  11.     Sockets1: TSockets;
  12.     Sockets2: TSockets;
  13.     MainMenu1: TMainMenu;
  14.     FileMNU: TMenuItem;
  15.     ExitMNU: TMenuItem;
  16.     DirCommandMNU: TMenuItem;
  17.     ConnectMNU: TMenuItem;
  18.     DirMNU: TMenuItem;
  19.     GetMNU: TMenuItem;
  20.     PutMNU: TMenuItem;
  21.     ChDirMNU: TMenuItem;
  22.     MkDirMNU: TMenuItem;
  23.     RmDirMNU: TMenuItem;
  24.     QuitMNU: TMenuItem;
  25.     DeleteMNU: TMenuItem;
  26.     RenameMNU: TMenuItem;
  27.     PwdMNU: TMenuItem;
  28.     N1: TMenuItem;
  29.     FileTransMNU: TMenuItem;
  30.     HelpMNU: TMenuItem;
  31.     QuoteMNU: TMenuItem;
  32.     Memo1: TMemo;
  33.     MiscCommMNU: TMenuItem;
  34.     ViewMNU: TMenuItem;
  35.     CancelMNU: TMenuItem;
  36.     ParentMNU: TMenuItem;
  37.     OptionsMNU: TMenuItem;
  38.     DirSepMNU: TMenuItem;
  39.     ViewSepMNU: TMenuItem;
  40.     EditorMNU: TMenuItem;
  41.     procedure Sockets1ErrorOccurred(Sender: TObject; Socket: integer; Error: Integer;
  42.       Msg: String);
  43.     procedure ConnectMNUClick(Sender: TObject);
  44.     procedure DirMNUClick(Sender: TObject);
  45.     procedure QuitMNUClick(Sender: TObject);
  46.     procedure GetMNUClick(Sender: TObject);
  47.     procedure PutMNUClick(Sender: TObject);
  48.     procedure ExitMNUClick(Sender: TObject);
  49.     procedure ChDirMNUClick(Sender: TObject);
  50.     procedure MkDirMNUClick(Sender: TObject);
  51.     procedure RmDirMNUClick(Sender: TObject);
  52.     procedure PwdMNUClick(Sender: TObject);
  53.     procedure RenameMNUClick(Sender: TObject);
  54.     procedure DeleteMNUClick(Sender: TObject);
  55.     procedure HelpMNUClick(Sender: TObject);
  56.     procedure QuoteMNUClick(Sender: TObject);
  57.     procedure EnableDisableMenus;
  58.     procedure FormCreate(Sender: TObject);
  59.     procedure ViewMNUClick(Sender: TObject);
  60.     procedure CancelMNUClick(Sender: TObject);
  61.     procedure ParentMNUClick(Sender: TObject);
  62.     procedure EditorMNUClick(Sender: TObject);
  63.     procedure DirSepMNUClick(Sender: TObject);
  64.     procedure ViewSepMNUClick(Sender: TObject);
  65.   private
  66.     procedure DoPrintf(line: string; const args: array of const);
  67.     function DoDirList(cmd: string;const args: array of const): integer;
  68.     function ReadDisplayLine: integer;
  69.     function GetFTPListenPort: integer;
  70.     procedure RetrieveFile(cmd: string;LocalName: string; rtype: string);
  71.     function TimedOut: Boolean;
  72.     function getreply(cmdstring: string): integer;
  73.     function command(fmt: string; const args: array of const): integer;
  74.     procedure DoAddLine(Buff: string);
  75.     procedure ImBusy;
  76.     procedure ImFree;
  77.     procedure UpdateGauge(BytesWritten,TotalTransferSize: longint);
  78.     procedure CancelGauge;
  79.     function GetTotalRetrieveSize: longint;
  80.   public
  81.   end;
  82.  
  83. const
  84.   FTP_PRELIM = 1;
  85.   FTP_COMPLETE = 2;
  86.   FTP_CONTINUE = 3;
  87.   FTP_RETRY = 4;
  88.   FTP_ERROR = 5;
  89.  
  90. var
  91.   FTPForm: TFTPForm;
  92.   line,GlobalBuff: string;
  93.   ErrorReturn: integer;
  94.   Aborted: Boolean;
  95.   Connected: Boolean;
  96.   CmdInProgress: Boolean;
  97.   DirSep, ViewSep, Editor: string;
  98.  
  99. implementation
  100.  
  101.  
  102. {$R *.DFM}
  103.  
  104. procedure TFTPForm.Sockets1ErrorOccurred(Sender: TObject; Socket: integer; Error: Integer;
  105.   Msg: String);
  106. var
  107.   szMsg: array[0..255] of char;
  108. begin
  109.   ErrorReturn := Error;
  110.   if Error = WSAETIMEDOUT then
  111.   begin
  112.     Aborted := True;
  113.     ErrorReturn := 0;
  114.   end
  115.   else
  116.   begin
  117.     StrPCopy(szMsg,'Error: '+IntToStr(Error)+#13#10+Msg);
  118.     Application.MessageBox(szMsg,'Error',MB_ICONEXCLAMATION);
  119.   end;
  120. end;
  121.  
  122. procedure TFTPForm.RetrieveFile(cmd: string;LocalName: string; rtype: string);
  123. var
  124.   FileName: string;
  125.   szFileName: array[0..255] of char;
  126.   RecvData: string;
  127.   IsDirList: Boolean;
  128.   IsView: Boolean;
  129.   Separate: Boolean;
  130.   szBuffer: array[0..255] of char;
  131.   output_file: integer;
  132.   iret: integer;
  133.   len: integer;
  134.   szTempFileName: array[0..63] of char;
  135.   szCmd: array[0..63] of char;
  136.   BytesWritten: longint;
  137.   TotalRetrieveSize: longint;
  138. begin
  139.   BytesWritten := 0;
  140.   Aborted := False;
  141.   Separate := False;
  142.   output_file := 0;
  143.   { determine what the retrieve is going to do...
  144.     1) Retrieve a file
  145.     2) Directory listing
  146.        2.1) inline
  147.        2.2) seperate editor session
  148.     3) View a file
  149.        3.1) inline
  150.        3.2) seperate editor session
  151.   }
  152.   if (LocalName = '') and (copy(cmd,1,4) <> 'LIST') then
  153.   begin { goal is to view the file }
  154.     IsView := True;
  155.     if ViewSep = '1' then {separately or inline?}
  156.     begin
  157.       Separate := True;
  158.       GetTempFileName('.','VIW',0,szTempFileName);
  159.       output_file := _lcreat(szTempFileName,0);
  160.     end;
  161.   end
  162.   else
  163.     IsView := False;
  164.   IsDirList := False;
  165.   if copy(cmd,1,4) = 'LIST' then {goal is to perform directory listing}
  166.   begin
  167.     IsDirList := True;
  168.     if DirSep = '1' then {separately or inline?}
  169.     begin
  170.       Separate := True;
  171.       GetTempFileName('.','LST',0,szTempFileName);
  172.       output_file := _lcreat(szTempFileName,0);
  173.     end;
  174.   end;
  175.   if not IsDirList then
  176.   begin
  177.     if not IsView then {goal is to retrieve a file}
  178.     begin
  179.       Separate := True;
  180.       StrPCopy(szFileName,LocalName);
  181.       output_file := _lcreat(szFileName,0);
  182.       if output_file = -1 then
  183.       begin
  184.         Application.MessageBox('Could not open file','_lopen error',MB_ICONEXCLAMATION);
  185.         output_file := 0;
  186.         exit;
  187.       end;
  188.     end;
  189.   end;
  190.   if command(rtype,[nil]) = FTP_ERROR then
  191.     exit;
  192.   Sockets2.NonBlocking := False;
  193.   Sockets2.Timeout := 30;
  194.   if GetFTPListenPort = FTP_ERROR then
  195.   begin
  196.     Sockets2.SCancelListen;
  197.     exit;
  198.   end;
  199.   if IsDirList then
  200.   begin
  201.     if Separate then
  202.     begin
  203.       command('PWD',[nil]);
  204.       StrPCopy(szBuffer,GlobalBuff);
  205.       _lwrite(output_file,szBuffer,StrLen(szBuffer));
  206.       StrPCopy(szBuffer,cmd+#13#10);
  207.       _lwrite(output_file,szBuffer,StrLen(szBuffer));
  208.     end;
  209.     Sockets1.Timeout := 0; {infinite timeout}
  210.     iret := command(cmd,[nil]);
  211.     Sockets1.Timeout := 30;
  212.     if (iret = FTP_RETRY) or (iret = FTP_ERROR) then
  213.     begin
  214.       DoPrintf('Could not list directory',[nil]);
  215.       Sockets2.SCancelListen;
  216.       exit;
  217.     end;
  218.   end
  219.   else
  220.   begin
  221.     iret := command('RETR %s',[cmd]);
  222.     if (iret = FTP_RETRY) or (iret = FTP_ERROR) then
  223.     begin
  224.       DoPrintf('Could not retrieve file',[nil]);
  225.       _lclose(output_file);
  226.       Sockets2.SCancelListen;
  227.       exit;
  228.     end;
  229.     TotalRetrieveSize := GetTotalRetrieveSize;
  230.   end;
  231.   ImBusy;
  232.   Sockets2.SAccept;
  233.   ImFree;
  234.   if TimedOut or (ErrorReturn <> 0) then
  235.   begin
  236.     Application.Messagebox('Could not extablish data socket, operation canceled',
  237.       'ERROR',MB_ICONEXCLAMATION);
  238.     exit;
  239.   end;
  240.   ImBusy;
  241.   repeat
  242.     len := 255;
  243.     len := Sockets2.SReceive(Sockets2.SocketNumber,szBuffer,len);
  244.     szBuffer[len] := #0;
  245.     if len > 0 then
  246.     begin
  247.       if (IsDirList) and (not Separate) then
  248.         DoAddLine(StrPas(szBuffer))
  249.       else
  250.       if (IsView) and (not Separate) then
  251.         DoAddLine(StrPas(szBuffer))
  252.       else
  253.         begin
  254.           if _lwrite(output_file,szBuffer,len) = -1 then
  255.           begin
  256.             DoPrintf('%sWrite to file: %s failed, transfer incomplete',
  257.               [#13#10,LocalName]);
  258.             Aborted := True;
  259.           end;
  260.           if not IsDirList then
  261.           begin
  262.             BytesWritten := BytesWritten + len;
  263.             UpdateGauge(BytesWritten,TotalRetrieveSize);
  264.           end;
  265.         end;
  266.     end;
  267.     if TimedOut then
  268.     begin
  269.       Sockets1.OOB := 'ABOR'+#13#10;
  270.       ReadDisplayLine;
  271.     end;
  272.   until len <= 0;
  273.   ImFree;
  274.   if Separate then
  275.   begin
  276.     _lclose(output_file);
  277.     output_file := 0;
  278.   end;
  279.   if IsDirList or IsView then
  280.     if Separate then
  281.     begin
  282.       StrPCopy(szCmd,Editor+' ');
  283.       StrCat(szCmd,szTempFileName);
  284.       WinExec(szCmd,SW_SHOW);
  285.     end;
  286.   Sockets2.SCancelListen;
  287.   Sockets2.SClose;
  288.   ReadDisplayLine;
  289.   CancelGauge;
  290. end;
  291.  
  292.  
  293. function TFTPForm.GetFTPListenPort: integer;
  294. var
  295.   i1,i2,i3,i4: integer;
  296.   IPAddr: string;
  297.   portcmd: string;
  298. begin
  299.   Sockets2.Port := '0';
  300.   Sockets2.SListen;
  301.   IPAddr := Sockets1.GetIPAddr(Sockets1.SocketNumber);
  302.   i1 := StrToInt(copy(IPAddr,1,pos('.',IPAddr)-1));
  303.   IPAddr := copy(IPAddr,pos('.',IPAddr)+1,255);
  304.   i2 := StrToInt(copy(IPAddr,1,pos('.',IPAddr)-1));
  305.   IPAddr := copy(IPAddr,pos('.',IPAddr)+1,255);
  306.   i3 := StrToInt(copy(IPAddr,1,pos('.',IPAddr)-1));
  307.   i4 := StrToInt(copy(IPAddr,pos('.',IPAddr)+1,255));
  308.   portcmd := format('PORT %d,%d,%d,%d,%d,%d',[i1,i2,i3,i4,
  309.     StrToInt(Sockets2.GetPort(Sockets2.MasterSocket)) Shr 8,
  310.     StrToInt(Sockets2.GetPort(Sockets2.MasterSocket)) and $ff]);
  311.   Result := command(portcmd,[nil]);
  312. end;
  313.  
  314. function TFTPForm.TimedOut;
  315. begin
  316.   if Aborted then
  317.   begin
  318.     Aborted := False;
  319.     Result := True;
  320.   end
  321.   else
  322.     Result := False;
  323. end;
  324.  
  325. function TFTPForm.getreply(cmdstring: string): integer;
  326. begin
  327.   Result := FTP_ERROR;
  328.   if copy(cmdstring,1,5) = 'PASS ' then
  329.     DoAddLine('PASS xxxxxx'+#13#10)
  330.   else
  331.     DoAddLine(cmdstring+#13#10);
  332.   if (Sockets1.SocketNumber = INVALID_SOCKET) or not Connected then
  333.   begin
  334.     DoAddLine('Not Connected'+#13#10);
  335.     exit;
  336.   end;
  337.   Sockets1.Text := cmdstring+#13#10;
  338.   if TimedOut or (ErrorReturn <> 0) then
  339.     exit;
  340.   Result := ReadDisplayLine;
  341. end;
  342.  
  343. function TFTPForm.command(fmt: string; const args: array of const): integer;
  344. var
  345.   Buf: string;
  346. begin
  347.   if CmdInProgress then
  348.   begin
  349.     DoPrintf('Command already in progress, request ignored',[nil]);
  350.     Result := -1;
  351.     exit;
  352.   end;
  353.   CmdInProgress := True;
  354.   ErrorReturn := 0;
  355.   ImBusy;
  356.   Buf := Format(fmt,args);
  357.   Result := getreply(Buf);
  358.   ImFree;
  359.   CmdInProgress := False;
  360. end;
  361.  
  362. function TFTPForm.DoDirList(cmd: string;const args: array of const): integer;
  363. var
  364.   Buf: string;
  365. begin
  366.   Buf := Format(cmd,args);
  367.   RetrieveFile(Buf,'','TYPE A');
  368. end;
  369.  
  370. procedure TFTPForm.DoPrintf(line: string; const args: array of const);
  371. var
  372.   str: string;
  373. begin
  374.   str := Format(line,args)+#13#10;
  375.   DoAddLine(str);
  376. end;
  377.  
  378. procedure TFTPForm.DoAddLine(Buff: string);
  379. var
  380.   idx,len,i: integer;
  381. begin
  382.   len := Length(Buff);
  383.   if len > 1 then
  384.   begin
  385.     for i := 1 to len do
  386.     begin
  387.       if Buff[i] = #10 then
  388.       begin
  389.         try
  390.         Memo1.Lines.Add(line);
  391.         except
  392.           on EOutOfResources do
  393.             begin
  394.               Memo1.Clear;
  395.               Memo1.Lines.Add('Cleared output area due to limited  resources');
  396.             end;
  397.         end;
  398.         line := '';
  399.       end
  400.       else
  401.         if Buff[i] <> #0 then
  402.           line := line + Buff[i];
  403.     end
  404.   end;
  405. end;
  406.  
  407.  
  408. function TFTPForm.ReadDisplayLine: integer;
  409. var
  410.   Buff: string;
  411.   szBuff: array[0..255] of char;
  412.   ch: char;
  413.   idx,len: integer;
  414. begin
  415.   Result := FTP_ERROR;
  416.   repeat
  417.     ch := #0;
  418.     Buff := Sockets1.Peek;
  419.     if TimedOut or (ErrorReturn <> 0) then
  420.       exit;
  421.     idx := pos(#10,Buff);
  422.     if idx > 0 then
  423.     begin
  424.       len := idx;
  425.       Sockets1.SReceive(Sockets1.SocketNumber,szBuff,len);
  426.       szBuff[len] := #0;
  427.       Buff := szBuff;
  428.       if TimedOut or (ErrorReturn <> 0) then
  429.         exit;
  430.       GlobalBuff := Buff;
  431.       DoAddLine(szBuff);
  432.       if szBuff[3] <> '-' then { continuation ? }
  433.         ch := szBuff[0];
  434.     end;
  435.   until (ch >= '1') and (ch <= '5');
  436.   Result := ord(ch) - $30;
  437. end;
  438.  
  439. procedure TFTPForm.ConnectMNUClick(Sender: TObject);
  440. var
  441.   iLength: integer;
  442.   iRetCode: integer;
  443.   iFlag: integer;
  444.   ftp_host: string;
  445. begin
  446.   if Connected then
  447.   begin
  448.     DoPrintf('Already connected to remote host: %s',[Sockets1.IPAddr]);
  449.     exit;
  450.   end;
  451.   line := '';
  452.   ErrorReturn := 0;
  453.   Memo1.Clear;
  454.   LoginDLG.ShowModal;
  455.   if LoginDLG.ModalResult = mrCancel then
  456.     exit;
  457.   ftp_host := LoginDLG.HostName.Text;
  458.   Sockets1.Port := '21';
  459.   Sockets1.IPAddr := ftp_host;
  460.   Sockets1.NonBlocking := False;
  461.   ImBusy;
  462.   Sockets1.SConnect;
  463.   ImFree;
  464.   if Aborted or (ErrorReturn <> 0) or (Sockets1.SocketNumber = INVALID_SOCKET) then
  465.   begin
  466.     DoPrintf('Connection to %s failed',[ftp_host]);
  467.     exit;
  468.   end;
  469.   Connected := True;
  470.   doprintf('Local port: %s IP: %s connected to rmt port: %s IP: %s',
  471.     [Sockets1.GetPort(Sockets1.SocketNumber),
  472.      Sockets1.GetIPAddr(Sockets1.SocketNumber),
  473.      Sockets1.GetPeerPort(Sockets1.SocketNumber),
  474.      Sockets1.GetPeerIPAddr(Sockets1.SocketNumber)]);
  475.   DoPrintf('Connected to %s',[Sockets1.IPAddr]);
  476.   repeat
  477.     iRetCode := ReadDisplayLine;
  478.   until (iRetCode <> FTP_PRELIM) or (Aborted = True);
  479.   if command('USER %s',[LoginDLG.UserName.Text]) = FTP_CONTINUE then
  480.     if LoginDLG.Password.Text <> '' then
  481.       if command('PASS %s',[LoginDlg.PassWord.Text]) = FTP_CONTINUE then
  482.         if LoginDLG.Account.Text <> '' then
  483.           command('ACCT %s',[LoginDLG.Account.Text]);
  484.   if LoginDLG.Directory.Text <> '' then
  485.     command('CWD %s',[LoginDLG.Directory.Text]);
  486.   EnableDisableMenus;
  487. end;
  488.  
  489. procedure TFTPForm.DirMNUClick(Sender: TObject);
  490. var
  491.   args: string;
  492. begin
  493.   args := '*.*';
  494.   if InputQuery('Remote Directory Listing','Pattern:',args) then
  495.     if args = '*.*' then
  496.       DoDirlist('LIST',[nil])
  497.     else
  498.       DoDirList('LIST %s',[args]);
  499. end;
  500.  
  501. procedure TFTPForm.QuitMNUClick(Sender: TObject);
  502. begin
  503.   command('QUIT',[nil]);
  504.   Sockets1.SClose;
  505.   Connected := False;
  506.   EnableDisableMenus;
  507. end;
  508.  
  509. procedure TFTPForm.GetMNUClick(Sender: TObject);
  510. var
  511.   rtype: string;
  512. begin
  513.   GetDLG.ShowModal;
  514.   if GetDLG.ModalResult = mrCancel then
  515.     exit;
  516.   if GetDLG.rbASCII.Checked = True then
  517.     rtype := 'TYPE A'
  518.   else if GetDLG.rbBINARY.Checked = True then
  519.     rtype := 'TYPE I'
  520.     else
  521.       rtype := 'TYPE E';
  522.   RetrieveFile(GetDLG.FileName.Text,GetDlg.LocalName.Text,rtype);
  523. end;
  524.  
  525. procedure TFTPForm.PutMNUClick(Sender: TObject);
  526. var
  527.   PCFile, RMTFile: string;
  528.   szPCFile: array[0..255] of char;
  529.   NumBytes: integer;
  530.   BytesWritten: longint;
  531.   Buff: string;
  532.   szBuff: array[0..255] of char;
  533.   trans_type: string;
  534.   input_file: integer;
  535.   TotalSendSize: longint;
  536. begin
  537.   PutDLG.ShowModal;
  538.   if PutDLG.ModalResult = mrCancel then
  539.     exit;
  540.   if PutDLG.rbASCII.Checked = True then
  541.     trans_type := 'TYPE A'
  542.   else if PutDLG.rbBINARY.Checked = True then
  543.     trans_type := 'TYPE I'
  544.     else
  545.       trans_type := 'TYPE E';
  546.   StrPCopy(szPCFile,PutDLG.FileName.Text);
  547.   input_file := _lopen(szPCFile,0);
  548.   if input_file = -1 then
  549.   begin
  550.     Application.MessageBox('Could not open local file','open error',MB_ICONEXCLAMATION);
  551.     exit;
  552.   end;
  553.   TotalSendSize := _llseek(input_file,0,2);
  554.   _llseek(input_file,0,0);
  555.   DoPrintf('Transferring local file: %s to remote file: %s',
  556.     [PutDLG.FileName.Text,PutDLG.RemoteName.Text]);
  557.   command(trans_type,[nil]);
  558.   Sockets2.NonBlocking := False;
  559.   Sockets2.Timeout := 30;
  560.   GetFTPListenPort;
  561.   command('STOR %s',[PutDLG.RemoteName.Text]);
  562.   Sockets2.SAccept;
  563.   BytesWritten := 0;
  564.   ImBusy;
  565.   NumBytes := _lread(input_file,@szBuff[0],255);
  566.   while NumBytes > 0 do
  567.   begin
  568.     Sockets2.SSend(Sockets2.SocketNumber,szBuff,NumBytes);
  569.     BytesWritten := BytesWritten + NumBytes;
  570.     UpdateGauge(BytesWritten,TotalSendSize);
  571.     NumBytes := _lread(input_file,@szBuff[0],255);
  572.     if TimedOut then
  573.     begin
  574.       Sockets1.OOB := 'ABOR'+#13#10;
  575.       ReadDisplayLine;
  576.       Sockets2.SCancelListen;
  577.       Sockets2.SClose;
  578.       _lclose(input_file);
  579.       ImFree;
  580.       DoPrintf('%sTransfer aborted due to you''re request',[#13#10]);
  581.       exit;
  582.     end;
  583.   end;
  584.   if NumBytes = -1 then
  585.     DoPrintf('File Error, File transfer may be incomplete',[nil]);
  586.   Sockets2.SCancelListen;
  587.   Sockets2.SClose;
  588.   _lclose(input_file);
  589.   ImFree;
  590.   DoPrintf('Total bytes written to remote host: %s',[IntToStr(BytesWritten)]);
  591.   ReadDisplayLine;
  592.   CancelGauge;
  593. end;
  594.  
  595. procedure TFTPForm.ExitMNUClick(Sender: TObject);
  596. begin
  597.   if Connected then
  598.   begin
  599.     DoPrintf('Disconnecting from remote host: %s',[Sockets1.IPAddr]);
  600.     QuitMNUClick(self);
  601.   end;
  602.   Close;
  603. end;
  604.  
  605. procedure TFTPForm.ChDirMNUClick(Sender: TObject);
  606. var
  607.   args: string;
  608. begin
  609.   args := '';
  610.   if InputQuery('Change Directory','Directory:',args) then
  611.     command('CWD %s',[args]);
  612. end;
  613.  
  614. procedure TFTPForm.ParentMNUClick(Sender: TObject);
  615. begin
  616.   command('CDUP',[nil]);
  617. end;
  618.  
  619. procedure TFTPForm.MkDirMNUClick(Sender: TObject);
  620. var
  621.   args: string;
  622. begin
  623.   args := '';
  624.   if InputQuery('Make Directory','Directory:',args) then
  625.     command('MKD %s',[args]);
  626. end;
  627.  
  628. procedure TFTPForm.RmDirMNUClick(Sender: TObject);
  629. var
  630.   args: string;
  631. begin
  632.   args := '';
  633.   if InputQuery('Remove Directory','Directory:',args) then
  634.     command('RMD %s',[args]);
  635. end;
  636.  
  637. procedure TFTPForm.PwdMNUClick(Sender: TObject);
  638. begin
  639.   command('PWD',[nil]);
  640. end;
  641.  
  642. procedure TFTPForm.RenameMNUClick(Sender: TObject);
  643. begin
  644.   RenDLG.ShowModal;
  645.   if RenDLG.ModalResult = mrCancel then
  646.     exit;
  647.   if command('RNFR %s',[RenDLG.FileFrom.Text]) = FTP_CONTINUE then
  648.     command('RNTO %s',[RenDLG.FileTo.Text]);
  649. end;
  650.  
  651.  
  652. procedure TFTPForm.DeleteMNUClick(Sender: TObject);
  653. var
  654.   args: string;
  655. begin
  656.   args := '';
  657.   if InputQuery('Delete Remote File','File to Delete:',args) then
  658.     command('DELE %s',[args]);
  659. end;
  660.  
  661. procedure TFTPForm.HelpMNUClick(Sender: TObject);
  662. begin
  663.   command('HELP',[nil]);
  664. end;
  665.  
  666. procedure TFTPForm.QuoteMNUClick(Sender: TObject);
  667. var
  668.   args: string;
  669. begin
  670.   args := '';
  671.   if InputQuery('Enter FTP command','Command:',args) then
  672.     command('%s',[args]);
  673. end;
  674.  
  675. procedure TFTPForm.EnableDisableMenus;
  676. var
  677.   ed: Boolean;
  678. begin
  679.   ed := False;
  680.   if Connected then
  681.     ed := True;
  682.   ChDirMNU.Enabled := ed;
  683.   ConnectMNU.Enabled := not ed;
  684.   DeleteMNU.Enabled := ed;
  685.   DirMNU.Enabled := ed;
  686.   GetMNU.Enabled := ed;
  687.   HelpMNU.Enabled := ed;
  688.   MkDirMNU.Enabled := ed;
  689.   PutMNU.Enabled := ed;
  690.   QuitMNU.Enabled := ed;
  691.   QuoteMNU.Enabled := ed;
  692.   RenameMNU.Enabled := ed;
  693.   RMDirMNU.Enabled := ed;
  694.   PwdMNU.Enabled := ed;
  695.   ViewMNU.Enabled := ed;
  696.   CancelMNU.Enabled := ed;
  697.   ParentMNU.Enabled := ed;
  698. end;
  699.  
  700. procedure TFTPForm.FormCreate(Sender: TObject);
  701. var
  702.   ftpini: TIniFile;
  703. begin
  704.   Connected := False;
  705.   EnableDisableMenus;
  706.   ftpini := TIniFile.Create('FTPPROF.INI');
  707.   DirSep := ftpini.ReadString('options','DirSep','');
  708.   ViewSep := ftpini.ReadString('options','ViewSep','');
  709.   Editor := ftpini.ReadString('options','Editor','');
  710.   if (DirSep = '') and (ViewSep = '') and (Editor = '') then
  711.   begin
  712.     DirSep := '0';
  713.     ftpini.WriteString('options','DirSep',DirSep);
  714.     ViewSep := '1';
  715.     ftpini.WriteString('options','ViewSep',ViewSep);
  716.     Editor := 'NOTEPAD.EXE';
  717.     ftpini.WriteString('options','Editor',Editor);
  718.   end;
  719.   if DirSep = '0' then
  720.     DirSepMNU.Checked := False
  721.   else
  722.     DirSepMnu.Checked := True;
  723.   if ViewSep = '0' then
  724.     ViewSepMNU.Checked := False         
  725.   else
  726.     ViewSepMnu.Checked := True;
  727.   Sockets1.MaximumReceiveLength := 255;
  728.   Sockets2.MaximumReceiveLength := 255;
  729. end;
  730.  
  731. procedure TFTPForm.ViewMNUClick(Sender: TObject);
  732. var
  733.  rtype: string;
  734. begin
  735.   ViewDLG.ShowModal;
  736.   if ViewDLG.ModalResult = mrCancel then
  737.     exit;
  738.   if ViewDLG.rbASCII.Checked = True then
  739.     rtype :=  'TYPE A'
  740.   else if ViewDLG.rbBINARY.Checked = True then
  741.     rtype := 'TYPE I'
  742.     else
  743.       rtype := 'TYPE E';
  744.   RetrieveFile(ViewDLG.FileName.Text,'',rtype);
  745. end;
  746.  
  747. procedure TFTPForm.CancelMNUClick(Sender: TObject);
  748. begin
  749.   Aborted := True;
  750. end;
  751.  
  752. procedure TFTPForm.ImBusy;
  753. begin
  754.   FTPForm.Cursor := crHourGlass;
  755.   Memo1.Cursor := crHourGlass;
  756. end;
  757.  
  758. procedure TFTPForm.ImFree;
  759. begin
  760.   FTPForm.Cursor := crDefault;
  761.   Memo1.Cursor := crDefault;
  762. end;
  763.  
  764.  
  765. procedure TFTPForm.EditorMNUClick(Sender: TObject);
  766. var
  767.   ftpini: TIniFile;
  768. begin
  769.   ftpini := TIniFile.Create('FTPPROF.INI');
  770.   Editor := ftpini.ReadString('options','Editor','');
  771.   Editor := InputBox('Enter preferred editor','Editor:',Editor);
  772.   ftpini.WriteString('options','Editor',Editor);
  773. end;
  774.  
  775. procedure TFTPForm.DirSepMNUClick(Sender: TObject);
  776. var
  777.   ftpini: TIniFile;
  778. begin
  779.   ftpini := TIniFile.Create('FTPPROF.INI');
  780.   if DirSep = '0' then
  781.   begin
  782.     DirSep := '1';
  783.     DirSepMNU.Checked := True;
  784.   end
  785.   else
  786.   begin
  787.     DirSep := '0';
  788.     DirSepMNU.Checked := False;
  789.   end;
  790.   ftpini.WriteString('options','DirSep',DirSep);
  791. end;
  792.  
  793. procedure TFTPForm.ViewSepMNUClick(Sender: TObject);
  794. var
  795.   ftpini: TIniFile;
  796. begin
  797.   ftpini := TIniFile.Create('FTPPROF.INI');
  798.   if ViewSep = '0' then
  799.   begin
  800.     ViewSep := '1';
  801.     ViewSepMNU.Checked := True;
  802.   end
  803.   else
  804.   begin
  805.     ViewSep := '0';
  806.     ViewSepMNU.Checked := False;
  807.   end;
  808.   ftpini.WriteString('options','ViewSep',ViewSep);
  809. end;
  810.  
  811. function TFTPForm.GetTotalRetrieveSize: longint;
  812. var
  813.   left,right: integer;
  814.   tmp: string;
  815. begin
  816.   left := pos('(',GlobalBuff);
  817.   if (left = 0) or (right = 0) then
  818.   begin
  819.     Result := 0;
  820.     exit;
  821.   end;
  822.   tmp := copy(GlobalBuff,left+1,right-left-1);
  823.   right := pos(' ',tmp);
  824.   if right <> 0 then
  825.     tmp := copy(tmp,1,right-1);
  826.   try
  827.     Result := StrToInt(tmp);
  828.   except
  829.     on EConvertError do Result := 0;
  830.   end;
  831. end;
  832.  
  833. procedure TFTPForm.UpdateGauge(BytesWritten, TotalTransferSize: longint);
  834. var
  835.   per, oldval: longint;
  836. begin
  837.   if TotalTransferSize = 0 then
  838.     exit;
  839.   if MeterDLG.Visible = False then
  840.     MeterDLG.Show;
  841.   oldval := MeterDLG.Gauge1.Progress;
  842.   per := trunc(100.0 / (TotalTransferSize / BytesWritten));
  843.   MeterDLG.Gauge1.Progress := per;
  844.   MeterDLG.Caption := IntToStr(per)+'% Complete';
  845.   if per <> oldval then
  846.     MeterDLG.Refresh;
  847. end;
  848.  
  849. procedure TFTPForm.CancelGauge;
  850. begin
  851.   MeterDLG.Hide;
  852. end;
  853.  
  854.  
  855. end.
  856.